home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
ratl10.zip
/
RATTLE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-10-23
|
20KB
|
583 lines
program Rattle;
{
Program: RATTLE.PAS
Version: 1.0
Creation Date: October 9, 1991
Modification Date: October 23, 1991
Operating System: MS-DOS 3.x and Windows 3.0
Hardware Reguired: Windows-capable computer system
Programming System: Turbo Pascal for Windows 1.0
Author: Craig Boyd
Ownership: Copyright 1991 by Craig Boyd
All rights reserved
About This Program
Rattle (as in "Shake Rattle 'n Roll") allocates and deallocates blocks
of memory in a random fashion, stress-testing other running Windows
applications by subjecting them to adverse and quickly changing memory
conditions. Rattle is functionally equivalent to Shaker, a utility
shipped with the Microsoft Windows Software Development Kit (SDK). That
is, it's as functionally equivalent as I can make it without ever laying
eyes on Shaker or its source code. My program is based on descriptions
of the Shaker algorithm obtained from SDK owners. Plus it has other
goodies that are all mine. See the RATTLE.WRI file for complete usage
and compilation instructions. Enjoy.
Update History
update ver description (author)
------- --- -----------
9110.09 0.0 Work begun. (CSB)
9110.11 0.0 Yay, we have a working app! (CSB)
9110.14 0.0 Added status display to AboutBox. (CSB)
9110.15 0.0 Fixed checkbox bug. (CSB)
9110.20 0.0 Added icon animation. (CSB)
9110.21 0.0 Added spacer memory blocks option. (CSB)
9110.23 1.0 Added 0 timer option to use Rattle as a memory hog.
Added option to save settings in WIN.INI.
First release uploaded to CompuServe. (CSB)
}
uses
Strings,
WinTypes,
WinProcs,
WObjects;
{$R-}
{$R Rattle}
{-- Global Declarations -------------------------------------------------}
const
AppName : pchar = 'Rattle';
id_BlockSize = 101; { control IDs }
id_BlockCount = 102;
id_TimerFreq = 103;
id_Sound = 104;
id_Minimize = 105;
id_Animate = 106;
id_Spacers = 107;
id_ShakeIt = 201; { buttons }
id_StopIt = 202;
id_Reset = 203;
id_SaveSettings = 204;
sc_About = 901; { system menu command for About box }
id_Status = 101; { static control in About box }
BlockFrac = 4; { size of spacer block: 4 = 1/4 of BlockSize }
Tick = true;
Tock = false;
type
TMyApp = object(TApplication)
procedure InitMainWindow; virtual;
end;
PBlockCollection = ^TBlockCollection;
TBlockCollection = object(TCollection)
procedure FreeItem(Item : pointer); virtual;
end;
PRattleSettings = ^TRattleSettings;
TRattleSettings = record
BlockSize, { size of memory blocks in bytes }
BlockCount, { max number of blocks }
TimerFreq : longint; { seconds between block allocations }
MakeSound, { true to beep when allocating }
Minimize, { true to minimize on start up }
Animate, { true to change icon on timer tick }
Spacers : boolean; { true to allocate spacer blocks }
end;
PRattleDlg = ^TRattleDlg;
TRattleDlg = object(TDlgWindow)
Settings,
StartSettings : TRattleSettings;
EditBlockSize,
EditBlockCount,
EditTimerFreq : PEdit;
ToggleSound,
ToggleMinimize,
ToggleAnimate,
ToggleSpacers : PCheckBox;
Blocks : PBlockCollection; { memory blocks }
Icon1,
Icon2 : hIcon;
IconState,
Running : boolean; { true if timer is running }
constructor Init(AParent : PWindowsObject;
AName : pchar;
InitSettings : TRattleSettings);
destructor Done; virtual;
procedure SetUpWindow; virtual;
function GetClassName : pchar; virtual;
procedure GetWindowClass(var AWndClass: TWndClass); virtual;
procedure WMSysCommand(var Msg : TMessage);
virtual wm_First + wm_SysCommand;
procedure WMTimer(var Msg : TMessage);
virtual wm_First + wm_Timer;
procedure ShakeIt(var Msg : TMessage); { start allocating RAM }
virtual id_First + id_ShakeIt;
procedure StopIt(var Msg : TMessage); { stop program, release RAM }
virtual id_First + id_StopIt;
procedure Reset(var Msg : TMessage); { restore startup settings }
virtual id_First + id_Reset;
procedure SaveSettings(var Msg : TMessage); { save setup in WIN.INI }
virtual id_First + id_SaveSettings;
procedure ResetParams; { restore startup settings }
function GetSettings : boolean; { get values from controls }
procedure ReadSettings; { read setup from WIN.INI }
procedure Error(Msg : pchar);
end;
PAboutDialog = ^TAboutDialog;
TAboutDialog = object(TDialog)
BlockSize,
Blocks : longint;
constructor Init(AParent : PWindowsObject;
AName : pchar;
InitBlockSize,
InitBlockCount : longint);
procedure SetupWindow; virtual;
end;
TNumStr = array[0..6] of char;
const
{ Program defaults, if none specified in WIN.INI }
DefSettings : TRattleSettings = (
BlockSize : 8192;
BlockCount : 20;
TimerFreq : 5;
MakeSound : false;
Minimize : true;
Animate : true;
Spacers : false);
{-- Global Procedures ---------------------------------------------------}
procedure BoolToStr(B : boolean;
S : pchar);
{
Converts the boolean value B into a string ('1' or '0') and stores
it in the character array pointed to by S.
}
begin
if B then strcopy(S,'1') else strcopy(S,'0');
end { BoolToStr };
{-- TRattleDlg Methods --------------------------------------------------}
constructor TRattleDlg.Init;
begin
TDlgWindow.Init(AParent,AName);
StartSettings := InitSettings;
ReadSettings;
Blocks := nil;
Running := false;
IconState := Tock;
randomize;
EditBlockSize := new(PEdit,InitResource(@Self,id_BlockSize,sizeof(TNumStr)));
EditBlockCount := new(PEdit,InitResource(@Self,id_BlockCount,sizeof(TNumStr)));
EditTimerFreq := new(PEdit,InitResource(@Self,id_TimerFreq,sizeof(TNumStr)));
ToggleSound := new(PCheckBox,InitResource(@Self,id_Sound));
ToggleMinimize := new(PCheckBox,InitResource(@Self,id_Minimize));
ToggleAnimate := new(PCheckBox,InitResource(@Self,id_Animate));
ToggleSpacers := new(PCheckBox,InitResource(@Self,id_Spacers));
end { TRattleDlg.Init };
destructor TRattleDlg.Done;
begin
if Running then KillTimer(HWindow,1);
if Blocks <> nil then dispose(Blocks,Done);
TDlgWindow.Done;
end { TRattleDlg.Done };
procedure TRattleDlg.SetUpWindow;
var
SysMenu : hMenu;
begin
TDlgWindow.SetUpWindow;
{ Add About option to system menu }
SysMenu := GetSystemMenu(hWindow,false);
AppendMenu(SysMenu,mf_separator,0,nil);
AppendMenu(SysMenu,mf_String,sc_About,'&About...');
{ Set default parameters }
ResetParams;
end { TRattleDlg.SetUpWindow };
function TRattleDlg.GetClassName;
begin
GetClassName := AppName;
end { TRattleDlg.GetClassName };
procedure TRattleDlg.GetWindowClass;
begin
TDlgWindow.GetWindowClass(AWndClass);
Icon1 := LoadIcon(HInstance,'Rattle1');
Icon2 := LoadIcon(HInstance,'Rattle2');
AWndClass.hIcon := Icon1;
end { TRattleDlg.GetWindowClass };
procedure TRattleDlg.WMSysCommand;
var
Dlg : PAboutDialog;
Count : longint;
begin
if Msg.wParam = sc_About then begin
if Blocks = nil then
Count := 0
else
Count := Blocks^.Count;
new(Dlg,Init(@Self,'AboutBox',Settings.BlockSize,Count));
Application^.ExecDialog(Dlg);
end;
DefWndProc(Msg);
end { TRattleDlg.WMSysCommand };
procedure TRattleDlg.WMTimer(var Msg : TMessage);
{
Responds to a wm_Timer message by adding a memory block to the Blocks
collection. The collection is not allowed to grow beyond the value set
by BlockCount. If the Blocks collection is full, then a memory block
is chosen at random and deleted. The collection never has more than
BlockCount items and never consumes more than BlockCount * BlockSize
bytes of memory.
We also check the Spacers flag before allocating a block. If true,
we temporarily allocate a small block of memory before adding a block
to our collection, then release the temporary block. This causes even
more heap fragmentation.
We also perform a couple of steps to make the program a little more fun
to use. Sillier, maybe, but definitely more fun. First, if the
MakeSound flag is set, we call MessageBeep. Second, if our window is
minimized and the Animate flag is set, we toggle the icon. These two
extra steps give you an audible and/or visual cue as to what Rattle is
up to.
This method is not called if TimerFreq is set to zero.
}
var
P,
Spacer : PHandle;
begin
with Settings do begin
if MakeSound then MessageBeep(0);
if (Animate) and (IsIconic(HWindow)) then begin
case IconState of
Tick : SetClassWord(HWindow,gcw_HIcon,Icon1);
Tock : SetClassWord(HWindow,gcw_HIcon,Icon2);
end;
IconState := not IconState;
InvalidateRect(HWindow,nil,true);
end;
if Blocks^.Count = BlockCount then
Blocks^.AtFree(random(BlockCount)) { free a memory block }
else
begin
if Spacers then begin
new(Spacer);
Spacer^ := GlobalAlloc(gmem_Fixed,BlockSize div BlockFrac);
GlobalLock(Spacer^);
end;
new(P); { get a handle }
P^ := GlobalAlloc(gmem_Fixed,BlockSize); { grab some memory }
if P^ <> 0 then begin
GlobalLock(P^); { lock it }
Blocks^.Insert(P); { add handle to collection }
end;
if Spacers then begin
GlobalUnlock(Spacer^);
GlobalFree(Spacer^);
dispose(Spacer);
end;
end;
end;
end { TRattleDlg.WMTimer };
procedure TRattleDlg.ShakeIt;
var
P : PHandle;
I : integer;
begin
if not GetSettings then exit; { read the controls }
with Settings do begin
if TimerFreq = 0 then { create collection and fill it }
begin
Blocks := new(PBlockCollection,Init(BlockCount,0));
for I := 1 to BlockCount do begin
new(P); { get a handle }
P^ := GlobalAlloc(gmem_Fixed,BlockSize); { grab some memory }
if P^ <> 0 then begin
GlobalLock(P^); { lock it }
Blocks^.Insert(P); { add handle to collection }
end;
end;
if MakeSound then MessageBeep(0);
end
else
begin
if SetTimer(HWindow,1,TimerFreq * 1000,nil) = 0 then begin
Error('No free timers');
exit;
end;
Running := true;
Blocks := new(PBlockCollection,Init(BlockCount,0));
end;
{ Disable all controls except Quit button, enable Stop It! button }
EnableWindow(GetItemHandle(id_BlockSize),false);
EnableWindow(GetItemHandle(id_BlockCount),false);
EnableWindow(GetItemHandle(id_TimerFreq),false);
EnableWindow(GetItemHandle(id_Sound),false);
EnableWindow(GetItemHandle(id_Minimize),false);
EnableWindow(GetItemHandle(id_Animate),false);
EnableWindow(GetItemHandle(id_Spacers),false);
EnableWindow(GetItemHandle(id_ShakeIt),false);
EnableWindow(GetItemHandle(id_StopIt),true);
EnableWindow(GetItemHandle(id_Reset),false);
EnableWindow(GetItemHandle(id_SaveSettings),false);
SetFocus(GetItemHandle(id_StopIt));
if Minimize then Show(sw_ShowMinimized);
end;
end { TRattleDlg.ShakeIt };
procedure TRattleDlg.StopIt;
begin
if Running then begin
KillTimer(HWindow,1);
Running := false;
end;
dispose(Blocks,Done);
Blocks := nil;
{ Enable all controls, disable Stop It! button }
EnableWindow(GetItemHandle(id_BlockSize),true);
EnableWindow(GetItemHandle(id_BlockCount),true);
EnableWindow(GetItemHandle(id_TimerFreq),true);
EnableWindow(GetItemHandle(id_Sound),true);
EnableWindow(GetItemHandle(id_Minimize),true);
EnableWindow(GetItemHandle(id_Animate),true);
EnableWindow(GetItemHandle(id_Spacers),true);
EnableWindow(GetItemHandle(id_ShakeIt),true);
EnableWindow(GetItemHandle(id_StopIt),false);
EnableWindow(GetItemHandle(id_Reset),true);
EnableWindow(GetItemHandle(id_SaveSettings),true);
SetFocus(GetItemHandle(id_ShakeIt));
end { TRattleDlg.StopIt };
procedure TRattleDlg.Reset;
begin
ResetParams;
end { TRattleDlg.Reset };
procedure TRattleDlg.SaveSettings;
{
Save the current control settings as the new defaults, and store them
in the WIN.INI file. They will be loaded the next time Rattle is
launched. The current settings also become the new default settings.
}
var
S : TNumStr;
begin
if not GetSettings then exit; { read the controls }
StartSettings := Settings;
with StartSettings do begin
str(BlockSize,S);
WriteProfileString(AppName,'BlockSize',S);
str(BlockCount,S);
WriteProfileString(AppName,'BlockCount',S);
str(TimerFreq,S);
WriteProfileString(AppName,'TimerFreq',S);
BoolToStr(MakeSound,S);
WriteProfileString(AppName,'Sound',S);
BoolToStr(Minimize,S);
WriteProfileString(AppName,'Minimize',S);
BoolToStr(Animate,S);
WriteProfileString(AppName,'Animate',S);
BoolToStr(Spacers,S);
WriteProfileString(AppName,'Spacers',S);
end;
end { TRattleDlg.SaveSettings };
procedure TRattleDlg.ResetParams;
{
Restore startup settings and update controls.
}
var
S : TNumStr;
begin
Settings := StartSettings;
with Settings do begin
str(BlockSize,S);
EditBlockSize^.SetText(S);
str(BlockCount,S);
EditBlockCount^.SetText(S);
str(TimerFreq,S);
EditTimerFreq^.SetText(S);
if MakeSound then ToggleSound^.Check else ToggleSound^.Uncheck;
if Minimize then ToggleMinimize^.Check else ToggleMinimize^.Uncheck;
if Animate then ToggleAnimate^.Check else ToggleAnimate^.Uncheck;
if Spacers then ToggleSpacers^.Check else ToggleSpacers^.Uncheck;
end;
end { TRattleDlg.ResetParams };
function TRattleDlg.GetSettings;
{
Read values from controls and store them in the Settings record.
Returns false if any numeric values are out of range.
}
var
S : TNumStr;
L : longint;
E : integer;
P : PHandle;
begin
GetSettings := false;
with Settings do begin
EditBlockSize^.GetText(S,sizeof(S));
val(S,L,E);
if (E <> 0) or (L < 1) then begin
Error('Invalid block size');
SetFocus(EditBlockSize^.HWindow);
EditBlockSize^.SetSelection(0,strlen(S));
exit;
end;
BlockSize := L;
EditBlockCount^.GetText(S,sizeof(S));
val(S,L,E);
if (E <> 0) or (L < 1) then begin
Error('Invalid block count');
SetFocus(EditBlockCount^.HWindow);
EditBlockCount^.SetSelection(0,strlen(S));
exit;
end;
BlockCount := L;
EditTimerFreq^.GetText(S,sizeof(S));
val(S,L,E);
if (E <> 0) or (L < 0) then begin
Error('Invalid timer frequency');
SetFocus(EditTimerFreq^.HWindow);
EditTimerFreq^.SetSelection(0,strlen(S));
exit;
end;
TimerFreq := L;
MakeSound := (ToggleSound^.GetCheck = bf_Checked);
Minimize := (ToggleMinimize^.GetCheck = bf_Checked);
Animate := (ToggleAnimate^.GetCheck = bf_Checked);
Spacers := (ToggleSpacers^.GetCheck = bf_Checked);
end;
GetSettings := true;
end { TRattleDlg.GetSettings };
procedure TRattleDlg.ReadSettings;
{
Loads the default program settings from WIN.INI. If the settings
cannot be found in WIN.INI, or if the value in WIN.INI is invalid,
then the startup variables are set to the values originally passed
in the Init method.
}
var
S,
Def : TNumStr;
L : longint;
E : integer;
procedure GetLongSetting(var Long : longint;
KeyName : pchar);
begin
str(L,Def);
GetProfileString(AppName,KeyName,Def,S,sizeof(S));
val(S,L,E);
if E = 0 then Long := L;
end;
procedure GetBoolSetting(var B : boolean;
KeyName : pchar);
begin
BoolToStr(B,Def);
GetProfileString(AppName,KeyName,Def,S,sizeof(S));
val(S,L,E);
if E = 0 then B := (L <> 0);
end;
begin
with StartSettings do begin
GetLongSetting(BlockSize,'BlockSize');
GetLongSetting(BlockCount,'BlockCount');
GetLongSetting(TimerFreq,'TimerFreq');
GetBoolSetting(MakeSound,'Sound');
GetBoolSetting(Minimize,'Minimize');
GetBoolSetting(Animate,'Animate');
GetBoolSetting(Spacers,'Spacers');
end;
end { TRattleDlg.ReadSettings };
procedure TRattleDlg.Error;
begin
MessageBeep(0);
MessageBox(HWindow,Msg,'Error',mb_OK or mb_IconExclamation);
end { TRattleDlg.Error };
{-- TBlockCollection Methods --------------------------------------------}
procedure TBlockCollection.FreeItem;
begin
if Item <> nil then begin
GlobalUnlock(PHandle(Item)^);
GlobalFree(PHandle(Item)^);
dispose(Item);
end;
end { TBlockCollection.FreeItem };
{-- TAboutDialog Methods ------------------------------------------------}
constructor TAboutDialog.Init;
begin
TDialog.Init(AParent,AName);
Blocks := InitBlockCount;
BlockSize := InitBlockSize;
end { TAboutDialog.Init };
procedure TAboutDialog.SetupWindow;
var
Stat : array[0..60] of char;
ArgList : array[0..1] of longint;
begin
if Blocks <> 0 then
begin
ArgList[0] := Blocks;
ArgList[1] := BlockSize * Blocks;
wvsprintf(Stat,'%lu blocks (%lu bytes) have been allocated.',ArgList);
end
else
strcopy(Stat,'No memory blocks allocated.');
SetWindowText(GetItemHandle(id_Status),Stat);
end { TAboutDialog.SetupWindow };
{-- TMyApp Methods ------------------------------------------------------}
procedure TMyApp.InitMainWindow;
begin
MainWindow := New(PRattleDlg,Init(nil,AppName,DefSettings));
end { TMyApp.InitMainWindow };
{-- Main Program --------------------------------------------------------}
var
MyApp : TMyApp;
begin
MyApp.Init(AppName);
MyApp.Run;
MyApp.Done;
end.